Nous souhaitons classifier un article du monde selon son contenu, Nous possèdons pour cela un jeu de données avec la catégorie et le contenu de 10k articles.

Pour mener notre tâche à bien nous allons effectuer un prétraitement des données textuelles par la transformation de données (textuelles) non structurées en un format de données structuré.

Et ce dans l’objectif d’appliquer des algorithmes de classifications, cela inclut la pondération et la sélection des variables(des mots).

Concrètement, il s’agit de la transformation d’un grand nombre de caractéristiques éparses en un nombre significativement plus petit de caractéristiques denses.

Nous utiliserons ainsi 3 algorithmes pour la classification dont un dans une version limitée à 25 variables explicatives.

Nous finirons par l’évaluation des résultats de la prédiction des classifications sur le jeu de test.

Résumé Ensemble variables explicatives Xi : nbre d’occurences des mots dans l’article. Variable à expliquer : la catégorie de l’article. Fonction de perte/évaluation : Matrice de confusion/AUC Algorithmes : CART, RandomForest, SVM Méthode pour éviter le sur-apprentissage : Validation croisée.

Introduction



## Import de la base de données & du jeu test

On utilise l’encodage UTF-8 car le monde est un journal français utilisant des caractères spéciaux. Le jeu de test est fournis, il a pour élément positif le fait d’être un article de type économie

data <- 
   read.csv("le_monde.csv", encoding="UTF-8", sep=";", comment.char="#")
test <- 
  read.csv("lignes_jeux_tests.csv")

Transformation des données



Il est nécessaire de transformer ces données, nous n’avons qu’une unique variable explicative : le texte en entier de l’article. Cette unique variable explicative est inexploitable, nous souhaitons un “bag of words”.

Suppression des deux collones non utiles à la modélisation

data$date <- NULL
data$title <- NULL



Nous n’avons pas à réaliser la gestion des manquants, tâche qui peut s’avérer très complexe. on supprime les lignes avec des valeurs manquantes (normalement aucune supprimmé)

## integer(0)



On applique les bons types de variables

data$category <- as.factor(data$category)
data$content <- as.character(data$content)
str(data)
## 'data.frame':    10000 obs. of  2 variables:
##  $ category: Factor w/ 6 levels "culture","economie",..: 6 5 5 2 5 5 5 5 1 5 ...
##  $ content : chr  "  / L’international français Jérémy Ménez va rejoindre le club de Bordeaux en Ligue 1, en provenance du Milan A"| __truncated__ "  / Le cousin d’un des assassins du Père Jacques Hamel à Saint-Etienne-du-Rouvray, identifié comme étant Farid "| __truncated__ "  / Si le premier ministre Manuel Valls constate que « l’islam a trouvé sa place dans la République », « face à"| __truncated__ "  / Les épargnants français sont choyés. Lundi 1er août, le taux de rémunération du Livret A aurait théoriqueme"| __truncated__ ...



On retire les accents, en effet dans l’une des étapes suivantes où l’on retire les caractères qui ne sont pas des lettres, les lettres avec accents font des trous dans les mots, rendant un grand nombre de mots inexploitable.

Une méthode plus professionel lors de l’import a été découvert à postériori



On a besoin d’un objet de type corpus, on prend là ou sont les données, ici la collone content. On affiche la première ligne

contenu <- Corpus(VectorSource(data$content))
contenu[1]$content
## [1] "  / L'international francais Jeremy Menez va rejoindre le club de Bordeaux en Ligue 1, en provenance du Milan AC, sous reserve de la traditionnelle visite medicale, a annonce le club aquitain dimanche. /  Menez est la troisieme recrue des Girondins apres le milieu de Monaco, Jeremy Toulalan, et l'attaquant guineen de Bastia, Francois Kamano. Bordeaux sort d'une pale saison et repart avec des ambitions nouvelles et l'entraineur Jocelyn Gourvennec, qui jouit d'une grosse cote grace a ses six saisons convaincantes a Guingamp. Age de 29 ans, Menez, qui compte 24 selections (2 buts) chez les Bleus -la derniere en 2013-, evoluait depuis deux ans au Milan AC, ou il lui restait un an de contrat, mais sa derniere saison a ete perturbee par des blessures. Forme a Sochaux, Menez fait partie de la fameuse generation 1987 championne d'Europe des U17 en 2004. Alors considere comme un des plus grands espoirs du foot francais, il avait par la suite rejoint Monaco de 2006 a 2008, puis la Roma pendant quatre saisons avant de revenir en France, au Paris-Saint-Germain en 2012. Son aventure parisienne, avec deux titres de champion a la cle, avait pris fin deux ans plus tard pour un retour en Italie, au Milan AC. Au sein de l'equipe lombarde il a realise sa meilleure saison (16 buts inscrits) en 2014-2015, avant d'etre perturbe par des blessures au dos la saison derniere qui l'ont prive de sept mois de competition, d'aout a janvier, pour ne disputer que 10 matchs (2 buts)."



On supprime les caracteres qui ne sont pas des lettres (cette étape posait problème avec les lettres à accent)

contenu <- tm_map(contenu, content_transformer(gsub), pattern = "[^a-zA-Z]", replacement = " ")
                 
contenu[1]$content
## [1] "    L international francais Jeremy Menez va rejoindre le club de Bordeaux en Ligue    en provenance du Milan AC  sous reserve de la traditionnelle visite medicale  a annonce le club aquitain dimanche     Menez est la troisieme recrue des Girondins apres le milieu de Monaco  Jeremy Toulalan  et l attaquant guineen de Bastia  Francois Kamano  Bordeaux sort d une pale saison et repart avec des ambitions nouvelles et l entraineur Jocelyn Gourvennec  qui jouit d une grosse cote grace a ses six saisons convaincantes a Guingamp  Age de    ans  Menez  qui compte    selections    buts  chez les Bleus  la derniere en        evoluait depuis deux ans au Milan AC  ou il lui restait un an de contrat  mais sa derniere saison a ete perturbee par des blessures  Forme a Sochaux  Menez fait partie de la fameuse generation      championne d Europe des U   en       Alors considere comme un des plus grands espoirs du foot francais  il avait par la suite rejoint Monaco de      a       puis la Roma pendant quatre saisons avant de revenir en France  au Paris Saint Germain en       Son aventure parisienne  avec deux titres de champion a la cle  avait pris fin deux ans plus tard pour un retour en Italie  au Milan AC  Au sein de l equipe lombarde il a realise sa meilleure saison     buts inscrits  en            avant d etre perturbe par des blessures au dos la saison derniere qui l ont prive de sept mois de competition  d aout a janvier  pour ne disputer que    matchs    buts  "



On mets les majuscules en minuscules

contenu <- tm_map(contenu, content_transformer(tolower))
contenu[1]$content
## [1] "    l international francais jeremy menez va rejoindre le club de bordeaux en ligue    en provenance du milan ac  sous reserve de la traditionnelle visite medicale  a annonce le club aquitain dimanche     menez est la troisieme recrue des girondins apres le milieu de monaco  jeremy toulalan  et l attaquant guineen de bastia  francois kamano  bordeaux sort d une pale saison et repart avec des ambitions nouvelles et l entraineur jocelyn gourvennec  qui jouit d une grosse cote grace a ses six saisons convaincantes a guingamp  age de    ans  menez  qui compte    selections    buts  chez les bleus  la derniere en        evoluait depuis deux ans au milan ac  ou il lui restait un an de contrat  mais sa derniere saison a ete perturbee par des blessures  forme a sochaux  menez fait partie de la fameuse generation      championne d europe des u   en       alors considere comme un des plus grands espoirs du foot francais  il avait par la suite rejoint monaco de      a       puis la roma pendant quatre saisons avant de revenir en france  au paris saint germain en       son aventure parisienne  avec deux titres de champion a la cle  avait pris fin deux ans plus tard pour un retour en italie  au milan ac  au sein de l equipe lombarde il a realise sa meilleure saison     buts inscrits  en            avant d etre perturbe par des blessures au dos la saison derniere qui l ont prive de sept mois de competition  d aout a janvier  pour ne disputer que    matchs    buts  "



On retire les lettres isolés et les mots “vides” tel “quand, comme, hors …”

stopwords_fr <- stopwords("french")
stopwords_fr <- c(stopwords_fr, "a","b","c","d","e","f","g","h","i","j","k","l","m","n","o","p","q","r","s","t",
                   "u","v","w","x","y","z" )
contenu <- tm_map(contenu, removeWords , stopwords_fr)
contenu[1]$content
## [1] "     international francais jeremy menez va rejoindre  club  bordeaux  ligue     provenance  milan ac  sous reserve   traditionnelle visite medicale   annonce  club aquitain dimanche     menez   troisieme recrue  girondins apres  milieu  monaco  jeremy toulalan    attaquant guineen  bastia  francois kamano  bordeaux sort   pale saison  repart   ambitions nouvelles   entraineur jocelyn gourvennec   jouit   grosse cote grace   six saisons convaincantes  guingamp  age     ans  menez   compte    selections    buts  chez  bleus   derniere         evoluait depuis deux ans  milan ac     restait  an  contrat    derniere saison  ete perturbee   blessures  forme  sochaux  menez fait partie   fameuse generation      championne  europe            alors considere comme   plus grands espoirs  foot francais      suite rejoint monaco              puis  roma pendant quatre saisons avant  revenir  france   paris saint germain         aventure parisienne   deux titres  champion   cle   pris fin deux ans plus tard   retour  italie   milan ac   sein   equipe lombarde   realise  meilleure saison     buts inscrits              avant  etre perturbe   blessures  dos  saison derniere    prive  sept mois  competition   aout  janvier    disputer     matchs    buts  "



Racinisation (sans retirer le premier espace)

contenu <- tm_map(contenu, stemDocument, "french")
#contenu[1]$content
contenu <- tm_map(contenu , stripWhitespace)
contenu <- tm_map(contenu, content_transformer(gsub), pattern = "^\\s+", replacement = "")
contenu[1]$content
## [1] "international franc jeremy men va rejoindr club bordeau ligu proven milan ac sous reserv traditionnel visit medical annonc club aquitain dimanch men troisiem recru girondin apre milieu monaco jeremy toulalan attaqu guineen basti francois kamano bordeau sort pal saison repart ambit nouvel entraineur jocelyn gourvennec jou gross cot grac six saison convainc guingamp age an men compt select but chez bleus dernier evolu depuis deux an milan ac rest an contrat dernier saison ete perturbe blessur form sochal men fait part fameux gener champion europ alor consider comm plus grand espoir foot franc suit rejoint monaco puis rom pend quatr saison avant reven franc paris saint germain aventur parisien deux titr champion cle pris fin deux an plus tard retour ital milan ac sein equip lombard realis meilleur saison but inscrit avant etre perturb blessur dos saison dernier priv sept mois competit aout janvi disput match but"



Vectorisation

Nous ne gardons que les mots avec 1000 occurences minimum



Le traitement de text effectué, on re-ajoute les données au tableau data pour comparer le texte de départ et le texte obtenu :

Le texte obtenu est correct.

Combien de fois les mots (variables) ont d’occurence dans le contenu des articles ?

summary(colSums(base_modele))
##    Min. 1st Qu.  Median    Mean 3rd Qu.    Max. 
##    1001    1223    1594    2222    2468   18909

On remarque une médiane à 1612 la haute valeur du maximum est surement dû à des mots vides (stop words) non retirer. Nous étudierons un modèle avec moins de variables (mots) dans une prochaine partie.



Testons notre hypothèse des stop words non retirer, en effet, il pourrait s’agir de mots apparaissant beaucoup dans une certaine catégorie d’articles. Regardons dans combien d’articles les mots sont référencés (sur 10k articles)

occurences <- apply(base_modele, 2, function(x) sum(x>0))
summary(occurences)
##    Min. 1st Qu.  Median    Mean 3rd Qu.    Max. 
##   350.0   863.5  1095.5  1388.4  1677.8  6247.0

Un maximum à 6237, soit 2/3 des documents. Nous verrons l’importance de ces mots dans le modèle lorsque nous réaliserons un modèle supervisé avec un maximum de 25 variables.



On construit alors notre modèle avec les catégories et les mots en variables.

base_modelisation = cbind.data.frame(data, base_modele)
base_modelisation = base_modelisation[,-2]
base_modelisation = base_modelisation[,-2]



#On prépare le jeu à 25 variables
#Somme <- colSums(base_modele)
#garder <- which(Somme > median(Somme))



# Présentation des données



## Analyse de la dispersion

Variables à expliquer : culture, economie, planete, politique, societe, sport.

439 Variables explicatives : les mots qui apparaissent plus de 1000 fois.

A noter que nous n’effectuons que les dernières partie d’un projet de Data Science, puisque les données nous ont été fournis. Avec ni gestion des manquants, ni gestion des fautes d’orthographes à réaliser (puisqu’il s’agit d’articles de presse).

Avant de réaliser des modèles de prédictions, détaillons le jeu de données transformé obtenu. Notre plus grande menace serait une corrélation globale de nos variables.

Visualisons graphiquement si nos variables sont très corrélés avec une heatmap :

Les variables sont très peu corrélés,



Pour complèter cela, on réalise une analyse en composante principale avec la catégorie en variable qualitative, ainsi en affichant les ellipse nous verrons les catégories qui s’opposent et quelles variables (les mots dans notre cas) sont les plus responsables des axes, autrement dit les plus importants.

#ces deux lignes sont marginales et ne permettent pas de ce centrer sur les individus.
#base_modelisation_ACP <- base_modelisation[-c(8808,5857), ]
#library(FactoMineR)
#res.pca = PCA(base_modelisation_ACP, scale.unit=TRUE, ncp=5, quali.sup=1, graph=T)

#Essayons de dégager une tendance avec les catégories
#library("factoextra")
#fviz_pca_ind(res.pca, geom.ind = "point", col.ind = base_modelisation_ACP$category, 
 #            palette = c("#00AFBB", "#E7B800", "#FC4E07", "#33FF5E","#CC33FF", "#FFC233"  ),
  #           addEllipses = TRUE, ellipse.type = "confidence",
   #          legend.title = "Catégorie de l'article"
#)



#plot.PCA(res.pca, axes=c(1, 2), choix="ind", habillage=1,label="var",graph.type = "ggplot")

Les deux premières dimensions ne rendent compte que de 10% de la variance, les graphiques sont inexploitables. Nous pouvons affirmer que les données sont très dispersés, leur non-corrélation est très forte.

Nuage de mots pour les catégories



Une fois la non-corrélation globale de nos variables assurés, Examinons graphiquement grâce à la librairie wordcloud les mots les plus fréquents par catégorie par un nuage de mots.

#Preparation des données pour le nuage des catégories
# on concatene tout le texte , on sélectionne la catégorie sport et spécicifie content_modif pour là où on prend le texte.

#motSport <- paste(data[data$category=="sport",'content_modif'],collapse=' ') 
#motSociete <- paste(data[data$category=="societe",'content_modif'],collapse=' ') 
#motEconomie <- paste(data[data$category=="economie",'content_modif'],collapse=' ') 
#motCulture <- paste(data[data$category=="culture",'content_modif'],collapse=' ') 
#motPolitique <- paste(data[data$category=="politique",'content_modif'],collapse=' ') 
#motPlanete <- paste(data[data$category=="planete",'content_modif'],collapse=' ') 


# on compte chaque mot, le motif entre guillemet veut dire qu'on coupe la #chainedecaractère quelque soit le nombre d'espaces entre les mots, decreasing en true car il faut montrer les most les plus fréquents , donc on met en décroissant (voir la doc de sort)

#motsFreqSport <- data.frame(sort(table(strsplit(motSport,"\\s+")),decreasing = TRUE )) 
#motsFreqSociete <- data.frame(sort(table(strsplit(motSociete,"\\s+")),decreasing = TRUE )) 
#motsFreqEconomie <- data.frame(sort(table(strsplit(motEconomie,"\\s+")),decreasing = TRUE )) 
#motsFreqCulture <- data.frame(sort(table(strsplit(motCulture,"\\s+")),decreasing = TRUE )) 
#motsFreqPolitique <- data.frame(sort(table(strsplit(motPolitique,"\\s+")),decreasing = TRUE )) 
#motsFreqPlanete <- data.frame(sort(table(strsplit(motPlanete,"\\s+")),decreasing = TRUE )) 

Création des nuages de mots

Sport

#wordcloud2(data = motsFreqSport[1:500,],minSize = 5, size = 3,shape = 'star',color = "random-light", backgroundColor = "grey")



Societe

#wordcloud2(data = motsFreqSociete[1:500,],minSize = 5, size = 3,shape = 'star',color = "random-light", backgroundColor = "grey")



Economie

#wordcloud2(data = motsFreqEconomie[1:500,],minSize = 5, size = 3,shape = 'star',color = "random-light", backgroundColor = "grey")



Culture

#wordcloud2(data = motsFreqCulture[1:500,],minSize = 5, size = 3,shape = 'star',color = "random-light", backgroundColor = "grey")



Politique

#wordcloud2(data = motsFreqPolitique[1:500,],minSize = 5, size = 3,shape = 'star',color = "random-light", backgroundColor = "grey")



Planete

#wordcloud2(data = motsFreqPlanete[1:500,],minSize = 5, size = 3,shape = 'star',color = "random-light", backgroundColor = "grey")

De nombreux mots semblent spécifiques à une seule catégorie, nous devrions obtenir de bons indicateurs de prédiction. D’un point de vue descriptif, si l’on ommet les mots vides non supprimmés, on peut expliquer Y (la catégorie) selon les mots présent dans l’article. En effet, si l’article parle d’un film, cela sera un article de catégorie culture. Cependant notre objectif n’est pas descriptif mais prédictif.



Avant de passer à la partie suivante, supprimons les données que nous n’utiliserons plus



A noter que nous pouvions effectuer ce changement sur nos données, en affectant 1 si l’article est de type économie et 0 sinon.

Cependant, la prédiction de toute les catégories possible nous semble avoir plus de sens.

#data$category <- gsub("economie", "1", data$category)
#data$category <- gsub("[^1]+", "0", data$category)
#data$category <- as.numeric(data$category)



# Premier modèle : CART



## Introduction Modèle Supervisé Apprentissage supervisé: expliquer/prédire une sortie Y à partir d’entrées X Nous devons éviter le sur-apprentissage, pour cela nous utiliserons la cross validation.

CrossValidation.png

Modèle supervisé utilisés : CART , Randomforest, SVM

Liste d’autres modèles : https://topepo.github.io/caret/available-models.html

La différence essentielle entre l’apprentissage supervisé et l’apprentissage non supervisé est que l’apprentissage supervisé traite la réponse/labels, contrairement à l’apprentissage non supervisé.



On commence par construire un modèle d’apprentissage, composé de 80% des lignes de base_modelisation. Le jeu de test est quand à lui fourni.

#nb_lignes <- sample(1:nrow(base_modelisation), nrow(base_modelisation)*0.80)
training <- base_modelisation[-test$x,]
testing <- base_modelisation[test$x,]

Création du modèle CART

Notre premier modèle est un arbre de décision.

Le principe est que, tant qu’on a pas atteind la taille minimal de noeuds enfants on recherche un seuil qui permet de séparer le noeud parents en 2 noeuds enfants en maximisant notre critère de répartition/de fractionnement.

Notre critère de répartition est le GINI, il est par défaut dans la fonction rpart.

On prend un cp choisi arbitrairement.

modele_CART <-rpart(category~. ,
             data = training,
             cp=0,
             minsplit = 10
            # ,control = rpart.control(minsplit = 10)
             )
visTree(modele_CART)

CP Hyperparamètre selection



On recherche le cp optimal.

plotcp(modele_CART)



On affine la prédiction en choisissant l’arbre avec l’erreur de prédiction la plus basse

Meilleur <- which.min(modele_CART$cptable[,"xerror"])
#Meilleur
cpBest <- modele_CART$cptable[Meilleur, "CP"]
cpBest
## [1] 0.0007527068
#cpBest
Modele_Cart_Arbre <- prune(modele_CART, cp = cpBest)
visTree(Modele_Cart_Arbre)
#Mauvaise méthode puisque le meilleur cp change d'une exécution à l'autre du code
#Besttree <-rpart(category~. ,
#                 data = base_modelisation[nb_lignes,],
#                cp=8e-04,
#               minsplit = 10
                   # ,control = rpart.control(minsplit = 10)
                 
#              )
#visTree(Besttree)
#print(Besttree$cptable)



#attributes(Modele_Cart_Arbre)
#construction plot
#plot(Modele_Cart_Arbre)
#text(Modele_Cart_Arbre, use.n=T)

CART Validation croisée

Ce modèle est très sensible à l’échantillonage, d’où la grande importance de la validation croisée pour lui.

Observons combien faut-il de temps pour calculer un arbre

#debut <- Sys.time()
#tree_temps <-rpart(category~. ,
 #            data = training,
  #           cp=0,
   #          minsplit = 10
            # ,control = rpart.control(minsplit = 10)
    #         )

#TempsArbre <- Sys.time() - debut
#print(paste("Pour générer un arbre, il faut : ", TempsArbre))

11 secondes ! Soit 320 arbres générés à l’heure. Voir plus selon le nombre de coeurs logiques pouvant être utilisés pour des calculs en simultanés.



Quel paramètre devons nous optimiser pour le modèle Cart Optimisons le cp.

Créons plusieurs modèle avec des cp différents

#cp_expand = expand.grid( .cp = seq(from = 0, to = 0.01, by = 0.00001)) 



On créé un grand nombre d’arbres par random forest, avec des configurations différentes du mtry

#require(caret)
#require(doSNOW)
  
#parametre du cv
#cv.cntrl <- trainControl(method = "cv", 
#                           number = 8, 
  #                         search = "grid")
  
 #on cree des instances , afin d'executer plus vite par l'utilisation de tout les coeurs
#mon processeur a 8 coeurs logiques , je mets donc 8,

  #cl <- makeCluster(8, 
     #               type = "SOCK") 
  #registerDoSNOW(cl)
  
  
  #set.seed(1234)
 

  #  modele_CART_CV <- train(x = training[,names(base_modelisation[nb_lignes,]) != 'category'],
    #                y = training$category,
    #                 method = 'rpart', trControl = cv.cntrl, 
      #               tuneGrid = cp_expand, metric = "Accuracy")
  

 # stopCluster(cl)
#On calcule ainsi cp expand x k-fold         = nbre d'arbres 
  #                   1000  x     8          = 8000



On affiche le modèle obtenu

#plot(modele_CART_CV)

CP Hyperparametre CV

Il s’agit pour ce modèle de l’unique hyper-parametre à optimiser.

On choisit à nouveau le cp

#modele_Cart_cv_best <- modele_CART_CV$bestTune$cp

#meilleur cp
#modele_Cart_cv_best
#0.00099

#cp_expand = expand.grid( .cp = modele_Cart_cv_best) 

cp_expand = expand.grid( .cp =  0.00099) 

#modele_cart_cv_final <- modele_CART_CV$results %>% filter(cp == modele_Cart_cv_best)



On recherche à nouveau avec le cp optimisé.

require(caret)
require(doSNOW)
## Loading required package: doSNOW
## Loading required package: foreach
## Loading required package: iterators
## Loading required package: snow
#parametre du cv
cv.cntrl <- trainControl(method = "cv", 
                           number = 8, 
                           search = "grid")
  

  cl <- makeCluster(8, 
                    type = "SOCK") 
  registerDoSNOW(cl)
  
  
  set.seed(1234)
 

    modele_CART_CV <- train(x = training[,names(testing) != 'category'],
                      y = training$category, 
                     method = 'rpart', trControl = cv.cntrl, 
                     tuneGrid = cp_expand, metric = "Accuracy")
  

  stopCluster(cl)
#modele_cart_cv_final
#print(modele_CART_CV$finalModel)



Importance des variables (si l’on choisit ce modèle pour réaliser un modèle limité à 25 variables)

sort(modele_CART_CV$finalModel$variable.importance, decreasing = TRUE)[1:25]
##     match      film     gauch      scen    polici entrepris       loi    joueur 
## 342.47353 267.37795 143.53286 128.68112 125.06311 112.39742  76.66093  75.88121 
##     final     euros      club    terror    saison   ministr       art  festival 
##  73.02005  71.37061  63.14927  59.35606  58.16061  57.15725  53.64389  51.28875 
##     selon      stad   primair       eur     polic    demand  attentat     contr 
##  48.37165  48.02982  45.05055  43.31238  40.41331  32.96050  29.75874  29.24274 
##   environ 
##  28.58325

Deuxième modèle : Random Forest

Création du modèle RF



Modélisation : Random Forest, algorithme de bagging

Le principe est de créer n arbres non corrélés entre eux puis faire voter chacun d’entre eux.

Pour faire varier un arbre on sélectionne une partie différente des données à chaque noeud et ne construisant des arbres que sur une partie des individus

Les paramètres que nous optimiserons seront le mtry et le maxnodes (nbre de feuilles).

Le paramètre mtry représente le nombre de variables échantillonnées de façon aléatoire comme candidats à chaque fractionnement. et nbtree est le nombre d’arbres générés.

#proximité entre les lignes calculés => afin de visualiser les individus aberrants/ representer en dimension 2 
 
                          
#modele_rf = randomForest(category~. 
  #                       , data=training,
      #                   importance = T,
              #           proximity=TRUE,
                  #       ntree = 5000)
#plot(modele_rf)
#print(modele_rf)
#modele_rf
#plot(modele_rf)

On observe une stagnation de l’erreur à partir de 400 arbres, nous utiliserons cette donnée pour la cross validation(on ne la calcule pas directement sur la cross validation par manque de puissance de calcul)

A noter que pour ce modele, nous sommes passer directement à la cross validation, sans optimiser les hyperparametres de base.



#proximité entre les lignes calculés
 
                          
modele_rf = randomForest(category~. 
                       , data=training,
                       importance = T,
                        proximity=TRUE,
                         ntree = 400)
#plot(modele_rf)
#print(modele_rf)
#modele_rf
plot(modele_rf)

Cross Validation

Quels paramètres devons-nous optimiser pour le modèle randomforest. Optimisons le mtry.



Observons combien faut-il de temps pour calculer 100 arbres à mon ordinateur.

debut <- Sys.time()
cent = randomForest(category~. 
                         , data=training,
                         importance = T,
                         ntree = 100)
TempsCent <- Sys.time() - debut
print(paste("Pour cent arbres, il faut : ", TempsCent))
## [1] "Pour cent arbres, il faut :  2.56772744655609"

1 minute et 45 secondes !

En 3h, il y a 180 minutes, je peux donc générer 10 000 arbres en 3h. et en 20 minutes je peux en calculer 1000. Et ce par coeurs logiques, soit potientiellement 8 fois plus.



Créons plusieurs modèle avec des mtry allant de 1 variables à toutes. En tout 439 configurations seront testés.

#mtry_expand = expand.grid( .mtry = seq(from = 1, to = (ncol(base_modelisation[nb_lignes,])-1), length.out = 439))
#length.out : premier multiplieur



On créé un grand nombre d’arbres par random forest, avec des configurations différentes du mtry, et grace à la librairie doSNOW on execute 8 fois plus vite le code.

#require(caret)
#require(doSNOW)
  
#parametre du cv
#cv.cntrl <- trainControl(method = "cv", 
            #               number = 8, 
                   #        search = "grid")
  

 # cl <- makeCluster(8, 
         #           type = "SOCK") 
 # registerDoSNOW(cl)
  
  
  #set.seed(1234)
 
  
  #méthode random forest 
   # modele_rf_cv <- train(x = base_modelisation[nb_lignes,][,names(base_modelisation[nb_lignes,]) != 'category'],
              #        y = base_modelisation[nb_lignes,]$category, 
                #      method = 'rf', trControl = cv.cntrl, 
                 #     tuneGrid = mtry_expand, metric = "Accuracy",
                   #   ntree = 100)
    #ntree est notre dernier multiplieur.
  
  
 # stopCluster(cl)
#On calcule ainsi length.out x kfold         x ntree = nbre d'arbres de notre modèle
  #                 439      x     8         x 100   = 351 000



Quel est le meilleur paramètre pour mtry

#modele_mtry <- modele_rf_cv$bestTune$mtry
#modele_rf_cv_best <- modele_rf_cv$results %>% filter(mtry==modele_mtry)
#le meilleur mtry est de :
#modele_mtry
mtry_expand <- expand.grid(.mtry = 33.21918)
#33.21918



On affiche le modèle obtenu

#plot(modele_rf_cv)
#plot(modele_rf_cv$finalModel$predicted)



Notre m-try est optimiser, optimisons désormais le maxnodes

#require(caret)
#require(doSNOW)
  
#sauvegarde des résultats
#list_maxnode <- list()

#parametre du cv
#cv.cntrl <- trainControl(method = "cv", 
    #                       number = 8, 
          #                 search = "grid")
  

  #cl <- makeCluster(8, 
     #               type = "SOCK") 
 # registerDoSNOW(cl)
  
  
#  set.seed(1234)
 
#for (maxnodes in c(0: 1)) {
  #méthode random forest 
    #modele_rf_cv <- train(x = training[,names(testing) != 'category'],
                #      y = training$category, 
             #         method = 'rf', 
                 #     trControl = cv.cntrl, 
                  #    tuneGrid = mtry_expand, 
                 #     metric = "Accuracy",
                #      importance = TRUE, 
                #      maxnodes = maxnodes,
                 #     ntree = 100)
    #ntree est notre dernier multiplieur.
    
 #   actuel <- toString(maxnodes)
   # list_maxnode[[actuel]] <- modele_rf_cv
  
  
#  }
# stopCluster(cl)
#results_mtry <- resamples(list_maxnode)
#summary(results_mtry)


#On calcule ainsi length.out x kfold         x ntree = nbre d'arbres de notre modèle
  #                 439      x     8         x 100   = 351 000

Le modèle au maxnode optimiser a des résultats totalement similaire.

En effet, https://topepo.github.io/caret/available-models.html ne précise pas le maxnode dans les tuning parameters.



Créons le modèle final.

require(caret)
require(doSNOW)
  
#parametre du cv
cv.cntrl <- trainControl(method = "cv", 
                           number = 8, 
                           search = "grid")
  

  cl <- makeCluster(8, 
                    type = "SOCK") 
 registerDoSNOW(cl)
  
  
  set.seed(1234)
 
  
  #méthode random forest 
    modele_rf_cv <- train(x = training[,names(testing) != 'category'],
                      y = training$category, 
                      method = 'rf', trControl = cv.cntrl, 
                     tuneGrid = mtry_expand, metric = "Accuracy",
                      ntree = 700)
    #ntree est notre dernier multiplieur.
  
  
  stopCluster(cl)

Troisième modèle

test K-nn



Certains algorithmes sont très sensibles à la variance des variables, ainsi Lasso, k-nn et SVM ont besoin d’une normalisation (voir standardisation) pour obtenir des résultats corrects. Cet aspect a été oublier lors de notre premier test de k-NN

#NROW(training)
# Renvoie 8000 -> racine carré de 8000 = 89.44 -> on créé deux modèles avec un k=89 et un avec k=90 
#library(dplyr)
#data_class <- base_modelisation
#category_outcome <- data_class %>% select(category)
#category_outcome <- category_outcome %>% mutate_if(is.character, as.factor)
#category_outcome_train <- category_outcome[nb_lignes, ]
#category_outcome_test <- category_outcome[-nb_lignes, ]
#knn_89 <- knn(training[-1], testing[-1], cl=category_outcome_train, k=89)
#knn_90 <- knn(training[-1], testing[-1], cl=category_outcome_train, k=90)
#ACC_89 <- 100 * sum(category_outcome_test == knn_89)/NROW(category_outcome_test)
#ACC_90 <- 100 * sum(category_outcome_test == knn_90)/NROW(category_outcome_test)
#confusionMatrix(table(knn_89 ,category_outcome_test))
#confusionMatrix(table(knn_90 ,category_outcome_test))

Création modèle SVM



Création d’un jeu de donnée normalisé, en effet les données sont à variance forte.

training_Scale <- training
testing_Scale <- testing
training_Scale[-1] <- scale(training_Scale[-1])
testing_Scale[-1] <- scale(testing_Scale[-1])



Création du modèle SVM grâce à la librairie e1071

Une fonction kernel transforme les données en trouvant un hyperplan qui sépare les différentes catégories (problème de classification), grâce à cette fonction, nos données sont toujours linéairement séparables. On test plusieurs fonctions kernel afin de trouver la meilleure.

#install.packages('e1071')
#library(e1071)
 
#modele_SVM = svm(formula = category~.,
#                 data = training_Scale,
  #               type = 'C-classification',
    #             kernel = 'linear')

# radial kernel est meilleur
library(e1071)
modele_SVM = svm(formula = category~.,
                 data = training_Scale,
                 type = 'C-classification',
                 kernel = 'radial')

la fonction kernel radial est la meilleure , comparé aux fonctions linear et poly.

Limite du choix effectué : Nous avons comparer ces fonctions sans optimiser leurs hyperparamètres

Hyperparamètre



On optimise les paramètres (model selection) Nous choississons d’optimiser cost et epsilon

#on recherche dans une grille 
#Tune_SVM <- tune(svm, category~.,  data = training_Scale,
#ranges = list(epsilon = seq(0,1,0.2), cost = 2^(2:9))
#)

# affichage de la recherche.
#print(Tune_SVM)
#plot(Tune_SVM)

Résultat du bloc au dessus :



Recherchons dans une plus grande étendue :



On sélectionne le meilleur modèle.

#SVM_Opti <- Tune_SVM$best.model
#SVM_Opti$cost
# 4 en cost

#SVM_Opti$epsilon
# 0 en epsilon



SVM_Opti = svm(formula = category~.,
                 data = training_Scale,
                 type = 'C-classification',
                 kernel = 'radial',
               cost=4,
               epsilon=0)

Validation croisée

On compare les différentes fonction en cross-validation, on remarque que svmRadial obtient de meilleure résultat.

Quels paramètres devons nous optimiser pour le modèle SvmRadial



Optimisons les paramètres sigma et C.

Mais en prenant en compte les erreurs de l’optimisation du modèle svm simple : l’étendu de recherche était mal défini.

Réalisons une recherche préliminaire pour savoir dans quels interval devons rechercher nos paramètres à optimiser.

#require(caret)
#require(doSNOW)

#library(caret)
#library(dplyr)         
#library(kernlab)  
  
#parametre du cv
#trCtrl <- trainControl(method="repeatedcv",   
      #               repeats=10    ,
               #      summaryFunction=twoClassSummary,  
            #         classProbs=TRUE
            #         )
  

 # cl <- makeCluster(8, 
        #            type = "SOCK") 
 # registerDoSNOW(cl)
  
  
 # set.seed(1234)
 
  
  #méthode SVM avec fonction kernel radial 
 # modele_SVM_CV <- train(
  # category~ .,
  # data = training_Scale,
 #  method = 'svmRadial',
  #   tuneLength = 15,  
  # preProcess = c("center", "scale"),
  #    metric="Accuracy",
  # trCtrl = trCtrl
 #)
    
  
 
   #stopCluster(cl)
 #
 #modele_SVM_CV

On remarque que la zone de recherche correct pour le cost est autour de la valeur 2

Et pour le sigma autour de la valeur 0.002

On recherche les paramètres optimaux dans cette zone de recherche restreinte.

require(caret)
require(doSNOW)
library(caret)
library(dplyr)         
## 
## Attaching package: 'dplyr'
## The following object is masked from 'package:randomForest':
## 
##     combine
## The following objects are masked from 'package:stats':
## 
##     filter, lag
## The following objects are masked from 'package:base':
## 
##     intersect, setdiff, setequal, union
library(kernlab)  
## 
## Attaching package: 'kernlab'
## The following object is masked from 'package:ggplot2':
## 
##     alpha
expand_cost_sigma <- expand.grid(sigma = c(.001, .002, 0.003),
                    C = c(1.5, 1.75, 2, 2.25, 2.5)
)

#parametre du cv
trCtrl <- trainControl(method="repeatedcv",   
                     repeats=10 ,
                     summaryFunction=twoClassSummary,   
                     classProbs=TRUE
                     )
  

  cl <- makeCluster(8, 
                    type = "SOCK") 
  registerDoSNOW(cl)
  
  
  set.seed(1234)
 
  
  #méthode SVM avec fonction kernel radial 
  modele_SVM_CV <- train(
  category~ .,
  data = training_Scale,
  method = 'svmRadial',
  tuneGrid = expand_cost_sigma,
  preProcess = c("center", "scale"),
     metric="Accuracy",
  trCtrl = trCtrl
)
    
  
 
  stopCluster(cl)

modele_SVM_CV
## Support Vector Machines with Radial Basis Function Kernel 
## 
## 8000 samples
##  442 predictor
##    6 classes: 'culture', 'economie', 'planete', 'politique', 'societe', 'sport' 
## 
## Pre-processing: centered (442), scaled (442) 
## Resampling: Bootstrapped (25 reps) 
## Summary of sample sizes: 8000, 8000, 8000, 8000, 8000, 8000, ... 
## Resampling results across tuning parameters:
## 
##   sigma  C     Accuracy   Kappa    
##   0.001  1.50  0.6658489  0.5776869
##   0.001  1.75  0.6666743  0.5790094
##   0.001  2.00  0.6665808  0.5791761
##   0.001  2.25  0.6672460  0.5802526
##   0.001  2.50  0.6669658  0.5800894
##   0.002  1.50  0.6583241  0.5668047
##   0.002  1.75  0.6581740  0.5668312
##   0.002  2.00  0.6585707  0.5675281
##   0.002  2.25  0.6581738  0.5671860
##   0.002  2.50  0.6579084  0.5669701
##   0.003  1.50  0.6374990  0.5373755
##   0.003  1.75  0.6372180  0.5372217
##   0.003  2.00  0.6364468  0.5363919
##   0.003  2.25  0.6363877  0.5364531
##   0.003  2.50  0.6355629  0.5355010
## 
## Accuracy was used to select the optimal model using the largest value.
## The final values used for the model were sigma = 0.001 and C = 2.25.





# Comparaison modèle

under-fitting lorsque notre modèle créé prédit avec beaucoup d’erreurs sur le jeu d’entrainement et de test. over-fitting lorsque notre modèle créé prédit avec très peu/aucune erreur le jeu d’entrainement mais avec beaucoup d’erreur le jeu de test.

Evaluation du premier modèle

CART [0.86]



Prédictions

#jeu d'entrainement
p_CART_train <- predict(Modele_Cart_Arbre,
             newdata=training,
           # newdata=test,  
           #trouver un moyen d'utiliser le jeu de test
           # type= "class"
             type= "class"
           )

#jeu de test
p_CART <- predict(Modele_Cart_Arbre,
             newdata=testing,
           # newdata=test,  
           #trouver un moyen d'utiliser le jeu de test
           # type= "class"
           type= "class"
           
           )



Matrices de confusion

#length(p_CART)

#jeu entrainement
conf_CART <- confusionMatrix(data=p_CART_train, reference = training$category)
conf_CART
## Confusion Matrix and Statistics
## 
##            Reference
## Prediction  culture economie planete politique societe sport
##   culture      1435      183     170        96     361   174
##   economie       91      924     122       108     256    46
##   planete         6        7      92        10      21     0
##   politique      56       83      47       607     163    22
##   societe       145      217     149       258    1409    60
##   sport          32       35       7        19      33   556
## 
## Overall Statistics
##                                           
##                Accuracy : 0.6279          
##                  95% CI : (0.6172, 0.6385)
##     No Information Rate : 0.2804          
##     P-Value [Acc > NIR] : < 2.2e-16       
##                                           
##                   Kappa : 0.5305          
##                                           
##  Mcnemar's Test P-Value : < 2.2e-16       
## 
## Statistics by Class:
## 
##                      Class: culture Class: economie Class: planete
## Sensitivity                  0.8130          0.6377        0.15673
## Specificity                  0.8422          0.9049        0.99406
## Pos Pred Value               0.5932          0.5973        0.67647
## Neg Pred Value               0.9409          0.9186        0.93705
## Prevalence                   0.2206          0.1811        0.07337
## Detection Rate               0.1794          0.1155        0.01150
## Detection Prevalence         0.3024          0.1934        0.01700
## Balanced Accuracy            0.8276          0.7713        0.57540
##                      Class: politique Class: societe Class: sport
## Sensitivity                   0.55282         0.6282      0.64802
## Specificity                   0.94625         0.8560      0.98236
## Pos Pred Value                0.62065         0.6296      0.81525
## Neg Pred Value                0.93008         0.8553      0.95873
## Prevalence                    0.13725         0.2804      0.10725
## Detection Rate                0.07587         0.1761      0.06950
## Detection Prevalence          0.12225         0.2797      0.08525
## Balanced Accuracy             0.74954         0.7421      0.81519
#jeu de test
conf_CART <- confusionMatrix(data=p_CART, reference = testing$category)
conf_CART
## Confusion Matrix and Statistics
## 
##            Reference
## Prediction  culture economie planete politique societe sport
##   culture       375       44      54        28     128    48
##   economie       29      170      42        45      70    12
##   planete         1        2      20         2       8     1
##   politique      12       32      14       133      68     7
##   societe        31       52      34        70     314    14
##   sport          10        7       1         7       8   107
## 
## Overall Statistics
##                                           
##                Accuracy : 0.5595          
##                  95% CI : (0.5374, 0.5814)
##     No Information Rate : 0.298           
##     P-Value [Acc > NIR] : < 2.2e-16       
##                                           
##                   Kappa : 0.4428          
##                                           
##  Mcnemar's Test P-Value : < 2.2e-16       
## 
## Statistics by Class:
## 
##                      Class: culture Class: economie Class: planete
## Sensitivity                  0.8188          0.5537         0.1212
## Specificity                  0.8042          0.8830         0.9924
## Pos Pred Value               0.5539          0.4620         0.5882
## Neg Pred Value               0.9373          0.9161         0.9262
## Prevalence                   0.2290          0.1535         0.0825
## Detection Rate               0.1875          0.0850         0.0100
## Detection Prevalence         0.3385          0.1840         0.0170
## Balanced Accuracy            0.8115          0.7184         0.5568
##                      Class: politique Class: societe Class: sport
## Sensitivity                    0.4667         0.5268       0.5661
## Specificity                    0.9224         0.8568       0.9818
## Pos Pred Value                 0.5000         0.6097       0.7643
## Neg Pred Value                 0.9123         0.8101       0.9559
## Prevalence                     0.1425         0.2980       0.0945
## Detection Rate                 0.0665         0.1570       0.0535
## Detection Prevalence           0.1330         0.2575       0.0700
## Balanced Accuracy              0.6946         0.6918       0.7740



AUC

library(ROCR)
library(pROC)


#jeu d'entrainement
p_CART_train <- predict(Modele_Cart_Arbre,
             newdata=training,
           # newdata=test,  
           #trouver un moyen d'utiliser le jeu de test
           # type= "class"
             type= "prob"
           )[,1]

#jeu de test
p_CART <- predict(Modele_Cart_Arbre,
             newdata=testing,
           # newdata=test,  
           #trouver un moyen d'utiliser le jeu de test
           # type= "class"
           type= "prob"
           
           )[,1]

#AUC jeu d'entrainement
auc(training$category, p_CART_train )
## Setting levels: control = culture, case = economie
## Setting direction: controls > cases
## Area under the curve: 0.8993
#AUC jeu de test
auc(testing$category, p_CART )
## Setting levels: control = culture, case = economie
## Setting direction: controls > cases
## Area under the curve: 0.8799

Un Auc de 0.86 a été obtenu avec notre jeu test. Et 0.90 avec le jeu d’entrainement.



Visualisation de la prédiction

plot(p_CART ~ category, data=testing, xlab="Observe",
       ylab="Predis")

CART Cross Validation 0.88



Prédiction

#jeu d'entrainement
pCART_CV_train <- predict(modele_CART_CV, newdata=training, type= "prob")
pCART_CV_train <- pCART_CV_train[,1]

#jeu de test
pCART_CV <- predict(modele_CART_CV, newdata=testing, type= "prob")
pCART_CV <- pCART_CV[,1]



Matrice de confusion jeu d’entrainement

MatriceConfu_CART_CV <- confusionMatrix(data = modele_CART_CV,
                                reference = training$category)
#labels <- c("Precision", "Recall", "F1", "Accuracy", "Kappa")
#confu3 <- MatriceConfu_CART_CV$byClass[labels[1:3]]
#confu3 <- c(confu3, MatriceConfu_CART_CV$overall[labels[4:5]])
MatriceConfu_CART_CV
## Cross-Validated (8 fold) Confusion Matrix 
## 
## (entries are percentual average cell counts across resamples)
##  
##            Reference
## Prediction  culture economie planete politique societe sport
##   culture      17.0      2.7     2.2       1.3     5.1   2.1
##   economie      1.4     10.4     1.7       1.9     4.2   0.7
##   planete       0.1      0.2     0.9       0.2     0.5   0.0
##   politique     0.9      1.3     0.7       7.0     3.2   0.3
##   societe       2.3      2.9     1.8       3.0    14.6   0.8
##   sport         0.4      0.5     0.1       0.2     0.5   6.8
##                             
##  Accuracy (average) : 0.5666



Matrice de confusion Jeu de test

MatriceConfu_CART_CV <- confusionMatrix(data = modele_CART_CV,
                                reference = testing$category)
#labels <- c("Precision", "Recall", "F1", "Accuracy", "Kappa")
#confu3 <- MatriceConfu_CART_CV$byClass[labels[1:3]]
#confu3 <- c(confu3, MatriceConfu_CART_CV$overall[labels[4:5]])
MatriceConfu_CART_CV
## Cross-Validated (8 fold) Confusion Matrix 
## 
## (entries are percentual average cell counts across resamples)
##  
##            Reference
## Prediction  culture economie planete politique societe sport
##   culture      17.0      2.7     2.2       1.3     5.1   2.1
##   economie      1.4     10.4     1.7       1.9     4.2   0.7
##   planete       0.1      0.2     0.9       0.2     0.5   0.0
##   politique     0.9      1.3     0.7       7.0     3.2   0.3
##   societe       2.3      2.9     1.8       3.0    14.6   0.8
##   sport         0.4      0.5     0.1       0.2     0.5   6.8
##                             
##  Accuracy (average) : 0.5666



AUC

length(testing$category)
## [1] 2000
#Auc Jeu d'entrainement
auc(training$category, pCART_CV_train)
## Warning in roc.default(response, predictor, auc = TRUE, ...): 'response'
## has more than two levels. Consider setting 'levels' explicitly or using
## 'multiclass.roc' instead
## Setting levels: control = culture, case = economie
## Setting direction: controls > cases
## Area under the curve: 0.8909
#AUC du jeu de test
auc(testing$category, pCART_CV)
## Warning in roc.default(response, predictor, auc = TRUE, ...): 'response'
## has more than two levels. Consider setting 'levels' explicitly or using
## 'multiclass.roc' instead
## Setting levels: control = culture, case = economie
## Setting direction: controls > cases
## Area under the curve: 0.8762

Un Auc de 0.93 a été trouver avec notre jeu de test. Et 0.89 avec le jeu d’entrainement.



#Visualisation de la prédiction
plot(pCART_CV ~ category, data=testing, xlab="Observe",
       ylab="Predis")

Evaluation du deuxième modèle :

Random Forest [0.91]



Predictions

#jeu d'entrainement
predict_rf_train <- predict(modele_rf, newdata=training, type= "prob")[,1]

#jeu de test
predict_rf <- predict(modele_rf, newdata=testing, type= "prob")[,1]



AUC

#length(testing$category)

#jeu d'entrainement
auc(training$category, predict_rf_train)
## Setting levels: control = culture, case = economie
## Setting direction: controls > cases
## Area under the curve: 0.9622
#jeu de test
auc(testing$category, predict_rf)
## Setting levels: control = culture, case = economie
## Setting direction: controls > cases
## Area under the curve: 0.926

Un AUC de 0.91 a été obtenu avec notre jeu de test. Et 0.99 avec le jeu d’entrainement.

Observons les résultats d’un AUC de grande qualité :

Test Prediction

table(predict_rf, testing$category)[1,]
##   culture  economie   planete politique   societe     sport 
##         0         0         0         0         0         1



Fréquence conditionel

table(predict_rf, testing$category)[1:7,]
##           
## predict_rf culture economie planete politique societe sport
##     0.0075       0        0       0         0       0     1
##     0.01         0        1       0         0       0     3
##     0.0125       0        1       0         1       0     1
##     0.015        0        0       0         0       1     0
##     0.0175       0        0       0         3       1     0
##     0.02         0        0       0         4       2     2
##     0.0225       0        0       0         2       4     1



plot(margin(modele_rf, testing$category))



#Visualisation de la prédiction
plot(predict_rf ~ category, data=testing, xlab="Observe",
       ylab="Predis")

Random Forest Cross Validation [0.92]



Prédiction

#jeu d'entrainement
pRF_CV_train <- predict(modele_rf_cv, newdata=training, type= "prob")
pRF_CV_train <- pRF_CV_train[,1]


#jeu de test
pRF_CV <- predict(modele_rf_cv, newdata=testing, type= "prob")
pRF_CV <- pRF_CV[,1]



Matrice de confusion

#jeu d'entrainement
MatriceConfu3 <- confusionMatrix(data = modele_rf_cv,
                                reference = training$category)
MatriceConfu3
## Cross-Validated (8 fold) Confusion Matrix 
## 
## (entries are percentual average cell counts across resamples)
##  
##            Reference
## Prediction  culture economie planete politique societe sport
##   culture      18.5      1.7     1.7       1.0     3.5   1.8
##   economie      0.9     12.4     1.5       1.2     2.4   0.4
##   planete       0.0      0.0     0.7       0.0     0.0   0.0
##   politique     0.5      0.7     0.5       8.2     1.6   0.1
##   societe       1.9      3.0     2.8       3.2    20.4   0.8
##   sport         0.3      0.2     0.0       0.1     0.1   7.6
##                             
##  Accuracy (average) : 0.6783
#jeu de test
MatriceConfu3 <- confusionMatrix(data = modele_rf_cv,
                                reference = testing$category)
MatriceConfu3
## Cross-Validated (8 fold) Confusion Matrix 
## 
## (entries are percentual average cell counts across resamples)
##  
##            Reference
## Prediction  culture economie planete politique societe sport
##   culture      18.5      1.7     1.7       1.0     3.5   1.8
##   economie      0.9     12.4     1.5       1.2     2.4   0.4
##   planete       0.0      0.0     0.7       0.0     0.0   0.0
##   politique     0.5      0.7     0.5       8.2     1.6   0.1
##   societe       1.9      3.0     2.8       3.2    20.4   0.8
##   sport         0.3      0.2     0.0       0.1     0.1   7.6
##                             
##  Accuracy (average) : 0.6783
#data = modele_rf_cv$finalModel$predicted

#labels <- c("Precision", "Recall", "F1", "Accuracy", "Kappa")
#confu3 <- MatriceConfu3$byClass[labels[1:3]]
#confu3 <- c(confu3, MatriceConfu3$overall[labels[4:5]])



AUC

#length(base_modelisation[-nb_lignes,]$category)

#jeu d'entrainement
auc(training$category, pRF_CV_train)
## Warning in roc.default(response, predictor, auc = TRUE, ...): 'response'
## has more than two levels. Consider setting 'levels' explicitly or using
## 'multiclass.roc' instead
## Setting levels: control = culture, case = economie
## Setting direction: controls > cases
## Area under the curve: 0.9622
#jeu de test
auc(testing$category, pRF_CV)
## Warning in roc.default(response, predictor, auc = TRUE, ...): 'response'
## has more than two levels. Consider setting 'levels' explicitly or using
## 'multiclass.roc' instead
## Setting levels: control = culture, case = economie
## Setting direction: controls > cases
## Area under the curve: 0.9264

Un Auc de 0.92 a été trouver avec notre jeu de test, et un AUC de 0.99 avec notre jeu d’entrainement.



#Visualisation de la prédiction
plot(pRF_CV ~ category, data=testing, xlab="Observe",
       ylab="Predis")

Troisième modèle

SVM [0.84]



Predictions

#jeu d'entrainement
SVM_pred_training = predict(SVM_Opti, newdata = training_Scale)
#jeu de test
SVM_pred = predict(SVM_Opti, newdata = testing_Scale)



Matrices de confusion

#Tableau_Pred_SVM = table(testing_Scale[,1], SVM_pred)
#Tableau_Pred_SVM

#jeu d'entrainement
MatriceConfu_SVM <- confusionMatrix(data = SVM_pred_training,
                                reference = training_Scale[,1])
MatriceConfu_SVM
## Confusion Matrix and Statistics
## 
##            Reference
## Prediction  culture economie planete politique societe sport
##   culture      1729       82     114        74     220   129
##   economie       15     1318      12        12      24     1
##   planete         0        1     444         2       0     0
##   politique       7       13       0       978      15     1
##   societe        13       33      17        32    1984     4
##   sport           1        2       0         0       0   723
## 
## Overall Statistics
##                                           
##                Accuracy : 0.897           
##                  95% CI : (0.8901, 0.9036)
##     No Information Rate : 0.2804          
##     P-Value [Acc > NIR] : < 2.2e-16       
##                                           
##                   Kappa : 0.8712          
##                                           
##  Mcnemar's Test P-Value : NA              
## 
## Statistics by Class:
## 
##                      Class: culture Class: economie Class: planete
## Sensitivity                  0.9796          0.9096        0.75639
## Specificity                  0.9007          0.9902        0.99960
## Pos Pred Value               0.7364          0.9537        0.99329
## Neg Pred Value               0.9936          0.9802        0.98107
## Prevalence                   0.2206          0.1811        0.07337
## Detection Rate               0.2161          0.1648        0.05550
## Detection Prevalence         0.2935          0.1727        0.05588
## Balanced Accuracy            0.9402          0.9499        0.87799
##                      Class: politique Class: societe Class: sport
## Sensitivity                    0.8907         0.8845      0.84266
## Specificity                    0.9948         0.9828      0.99958
## Pos Pred Value                 0.9645         0.9525      0.99587
## Neg Pred Value                 0.9828         0.9562      0.98144
## Prevalence                     0.1373         0.2804      0.10725
## Detection Rate                 0.1222         0.2480      0.09037
## Detection Prevalence           0.1268         0.2604      0.09075
## Balanced Accuracy              0.9427         0.9337      0.92112
#jeu de test
MatriceConfu_SVM <- confusionMatrix(data = SVM_pred,
                                reference = testing_Scale[,1])
MatriceConfu_SVM
## Confusion Matrix and Statistics
## 
##            Reference
## Prediction  culture economie planete politique societe sport
##   culture       387       21      34        20      90    37
##   economie       20      214      27        33      39     7
##   planete         0        9      61         2       9     2
##   politique       8       14       9       175      26     1
##   societe        38       48      32        54     432    15
##   sport           5        1       2         1       0   127
## 
## Overall Statistics
##                                           
##                Accuracy : 0.698           
##                  95% CI : (0.6773, 0.7181)
##     No Information Rate : 0.298           
##     P-Value [Acc > NIR] : < 2.2e-16       
##                                           
##                   Kappa : 0.6166          
##                                           
##  Mcnemar's Test P-Value : < 2.2e-16       
## 
## Statistics by Class:
## 
##                      Class: culture Class: economie Class: planete
## Sensitivity                  0.8450          0.6971         0.3697
## Specificity                  0.8690          0.9256         0.9880
## Pos Pred Value               0.6570          0.6294         0.7349
## Neg Pred Value               0.9497          0.9440         0.9457
## Prevalence                   0.2290          0.1535         0.0825
## Detection Rate               0.1935          0.1070         0.0305
## Detection Prevalence         0.2945          0.1700         0.0415
## Balanced Accuracy            0.8570          0.8113         0.6789
##                      Class: politique Class: societe Class: sport
## Sensitivity                    0.6140         0.7248       0.6720
## Specificity                    0.9662         0.8668       0.9950
## Pos Pred Value                 0.7511         0.6979       0.9338
## Neg Pred Value                 0.9377         0.8812       0.9667
## Prevalence                     0.1425         0.2980       0.0945
## Detection Rate                 0.0875         0.2160       0.0635
## Detection Prevalence           0.1165         0.3095       0.0680
## Balanced Accuracy              0.7901         0.7958       0.8335



AUC

library(ROCR)
library(pROC)

#auc(testing_Scale[,1], SVM_pred )
#plot(AUC_SVM, add = TRUE,col = "red", print.auc=TRUE, print.auc.x = 0.5, print.auc.y = 0.3)
#legend(0.3, 0.2, legend = c("auc svm"), lty = c(1), col = c("blue"))

#jeu d'entrainement
AUC_SVM_train <- roc(response =training_Scale$category, predictor =as.numeric(SVM_pred_training))
## Setting levels: control = culture, case = economie
## Setting direction: controls < cases
AUC_SVM_train
## 
## Call:
## roc.default(response = training_Scale$category, predictor = as.numeric(SVM_pred_training))
## 
## Data: as.numeric(SVM_pred_training) in 1765 controls (training_Scale$category culture) < 1449 cases (training_Scale$category economie).
## Area under the curve: 0.9562
#jeu de test
AUC_SVM <- roc(response =testing_Scale$category, predictor =as.numeric(SVM_pred))
## Setting levels: control = culture, case = economie
## Setting direction: controls < cases
AUC_SVM
## 
## Call:
## roc.default(response = testing_Scale$category, predictor = as.numeric(SVM_pred))
## 
## Data: as.numeric(SVM_pred) in 458 controls (testing_Scale$category culture) < 307 cases (testing_Scale$category economie).
## Area under the curve: 0.8515

AUC de 0.84 pour un SVM avec une fonction kernel en radial sur notre jeu de test, un AUC de 0.96 sur notre jeu d’entrainement.

SVM Validation croisée [0.86]



Prediction

SVM_pred_CV_train = predict(modele_SVM_CV, newdata = training_Scale)

SVM_pred_CV = predict(modele_SVM_CV, newdata = testing_Scale)



Matrice de confusion

#Tableau_Pred_SVM = table(testing_Scale[,1], SVM_pred)
#Tableau_Pred_SVM

#jeu d'entrainement
MatriceConfu_SVM <- confusionMatrix(data = SVM_pred_CV_train,
                                reference = training_Scale[,1])
MatriceConfu_SVM
## Confusion Matrix and Statistics
## 
##            Reference
## Prediction  culture economie planete politique societe sport
##   culture      1656      164     142       110     287   160
##   economie       41     1163      43        48      85    17
##   planete         0        1     332         4       3     1
##   politique      24       27      13       835      61     5
##   societe        41       91      57       101    1807    17
##   sport           3        3       0         0       0   658
## 
## Overall Statistics
##                                          
##                Accuracy : 0.8064         
##                  95% CI : (0.7975, 0.815)
##     No Information Rate : 0.2804         
##     P-Value [Acc > NIR] : < 2.2e-16      
##                                          
##                   Kappa : 0.7568         
##                                          
##  Mcnemar's Test P-Value : < 2.2e-16      
## 
## Statistics by Class:
## 
##                      Class: culture Class: economie Class: planete
## Sensitivity                  0.9382          0.8026        0.56559
## Specificity                  0.8616          0.9643        0.99879
## Pos Pred Value               0.6574          0.8325        0.97361
## Neg Pred Value               0.9801          0.9567        0.96671
## Prevalence                   0.2206          0.1811        0.07337
## Detection Rate               0.2070          0.1454        0.04150
## Detection Prevalence         0.3149          0.1746        0.04263
## Balanced Accuracy            0.8999          0.8835        0.78219
##                      Class: politique Class: societe Class: sport
## Sensitivity                    0.7605         0.8056      0.76690
## Specificity                    0.9812         0.9467      0.99916
## Pos Pred Value                 0.8653         0.8548      0.99096
## Neg Pred Value                 0.9626         0.9259      0.97274
## Prevalence                     0.1373         0.2804      0.10725
## Detection Rate                 0.1044         0.2259      0.08225
## Detection Prevalence           0.1206         0.2642      0.08300
## Balanced Accuracy              0.8708         0.8761      0.88303
#jeu de test
MatriceConfu_SVM <- confusionMatrix(data = SVM_pred_CV,
                                reference = testing_Scale[,1])
MatriceConfu_SVM
## Confusion Matrix and Statistics
## 
##            Reference
## Prediction  culture economie planete politique societe sport
##   culture       411       34      36        28      97    43
##   economie       16      208      26        39      45     5
##   planete         0        6      64         0       6     1
##   politique       7       17       8       169      32     2
##   societe        21       41      29        49     414    10
##   sport           3        1       2         0       2   128
## 
## Overall Statistics
##                                           
##                Accuracy : 0.697           
##                  95% CI : (0.6763, 0.7171)
##     No Information Rate : 0.298           
##     P-Value [Acc > NIR] : < 2.2e-16       
##                                           
##                   Kappa : 0.6161          
##                                           
##  Mcnemar's Test P-Value : < 2.2e-16       
## 
## Statistics by Class:
## 
##                      Class: culture Class: economie Class: planete
## Sensitivity                  0.8974          0.6775         0.3879
## Specificity                  0.8457          0.9226         0.9929
## Pos Pred Value               0.6333          0.6136         0.8312
## Neg Pred Value               0.9652          0.9404         0.9475
## Prevalence                   0.2290          0.1535         0.0825
## Detection Rate               0.2055          0.1040         0.0320
## Detection Prevalence         0.3245          0.1695         0.0385
## Balanced Accuracy            0.8715          0.8001         0.6904
##                      Class: politique Class: societe Class: sport
## Sensitivity                    0.5930         0.6946       0.6772
## Specificity                    0.9615         0.8932       0.9956
## Pos Pred Value                 0.7191         0.7340       0.9412
## Neg Pred Value                 0.9343         0.8733       0.9673
## Prevalence                     0.1425         0.2980       0.0945
## Detection Rate                 0.0845         0.2070       0.0640
## Detection Prevalence           0.1175         0.2820       0.0680
## Balanced Accuracy              0.7772         0.7939       0.8364



AUC

library(ROCR)
library(pROC)


#auc(testing_Scale[,1], SVM_pred )

#jeu d'entrainement
AUC_SVM <- roc(response =training_Scale$category, predictor =as.numeric(SVM_pred_CV_train))
## Setting levels: control = culture, case = economie
## Setting direction: controls < cases
AUC_SVM
## 
## Call:
## roc.default(response = training_Scale$category, predictor = as.numeric(SVM_pred_CV_train))
## 
## Data: as.numeric(SVM_pred_CV_train) in 1765 controls (training_Scale$category culture) < 1449 cases (training_Scale$category economie).
## Area under the curve: 0.8982
#jeu de test
AUC_SVM <- roc(response =testing_Scale$category, predictor =as.numeric(SVM_pred_CV))
## Setting levels: control = culture, case = economie
## Setting direction: controls < cases
AUC_SVM
## 
## Call:
## roc.default(response = testing_Scale$category, predictor = as.numeric(SVM_pred_CV))
## 
## Data: as.numeric(SVM_pred_CV) in 458 controls (testing_Scale$category culture) < 307 cases (testing_Scale$category economie).
## Area under the curve: 0.8727
#plot(AUC_SVM, add = TRUE,col = "red", print.auc=TRUE, print.auc.x = 0.5, print.auc.y = 0.3)
#legend(0.3, 0.2, legend = c("auc svm"), lty = c(1), col = c("blue"))

Auc de 0.81 et 0.93 avec le jeu d’entrainement.

Mise en œuvre d’un modèle supervisé avec maximum 25 variables [0.87]



On sélectionne les 25 variables les plus importantes parmis le 2ème modèle (random Forest) Ainsi qu’une visualisation graphique de leur importance.

#class (modele_rf$importance[order(modele_rf$importance[,1], decreasing = TRUE)[1:25], ])
#"matrix" "array" 
modele_rf$importance[order(modele_rf$importance[,1], decreasing = TRUE)[1:25], ]
##              culture      economie       planete    politique       societe
## selon     0.04216293 -0.0051173203 -1.962515e-04 5.057923e-04 -0.0005344292
## film      0.04029876  0.0089466572  2.463155e-03 7.448186e-03  0.0053271018
## entrepris 0.03579334  0.0144797465  2.054235e-03 4.795619e-03  0.0026832060
## loi       0.03479790  0.0003254555  2.131912e-03 1.281437e-02 -0.0010430549
## euros     0.03268176  0.0100383017  6.885532e-04 5.802675e-03  0.0002994413
## ministr   0.02945092  0.0083031675  2.660064e-03 7.070289e-03 -0.0027653856
## president 0.02908917  0.0015777301 -7.296709e-04 1.071072e-03 -0.0006754130
## scen      0.02742632  0.0098741178  2.887093e-03 2.740954e-03  0.0036834362
## ete       0.02631817  0.0041567879 -3.157007e-03 1.619967e-03 -0.0043228595
## festival  0.02215680  0.0048354841  1.237005e-03 4.162155e-03  0.0052881821
## person    0.01701067 -0.0009631154 -8.046964e-05 1.420561e-03  0.0004809063
## franc     0.01698759  0.0002129920 -1.377378e-03 9.626827e-05 -0.0024844547
## art       0.01675015  0.0033608950  1.582876e-03 3.085212e-03  0.0034206484
## gouvern   0.01656069  0.0032302476 -4.070245e-04 8.210426e-03 -0.0014972743
## plus      0.01650525 -0.0012461512 -2.077469e-03 6.748568e-04 -0.0033775871
## match     0.01627749  0.0063970883  2.733584e-03 3.201661e-03  0.0059478620
## equip     0.01540895 -0.0003723839  1.216765e-03 3.399567e-03  0.0015848936
## etat      0.01539604 -0.0003175508  1.358129e-03 5.312071e-04 -0.0007941831
## contr     0.01512810  0.0025783896 -2.929892e-04 5.222997e-04 -0.0024451609
## droit     0.01454674  0.0036667751  1.625480e-03 7.230506e-03 -0.0018784176
## econom    0.01305533  0.0004790546 -4.208606e-04 2.160567e-03  0.0028276272
## general   0.01276943 -0.0016441366  7.618404e-04 4.982094e-04  0.0001164916
## national  0.01255518  0.0049577766  6.989940e-04 2.248277e-03 -0.0012119144
## social    0.01173963 -0.0001087803  1.151339e-03 7.228159e-03 -0.0024094407
## final     0.01139763  0.0025905425  1.176448e-03 1.526407e-03  0.0017264310
##                   sport MeanDecreaseAccuracy MeanDecreaseGini
## selon      0.0071070454          0.009032113         38.95885
## film       0.0091316016          0.014198743        124.93272
## entrepris  0.0151895314          0.013703935         74.07658
## loi        0.0144407479          0.010905538         50.24063
## euros      0.0051019532          0.010501654         54.42654
## ministr    0.0107582995          0.009536748         47.16734
## president  0.0028416088          0.006911854         31.20840
## scen       0.0035047910          0.009838335         94.37908
## ete        0.0005409592          0.005401409         39.19634
## festival   0.0034053906          0.008273007         78.02602
## person     0.0031127932          0.004244731         27.81462
## franc     -0.0017380858          0.002825564         32.00026
## art        0.0041839374          0.006250916         56.73073
## gouvern    0.0093741121          0.005920604         34.50622
## plus      -0.0002871963          0.002371253         29.60321
## match      0.0708991864          0.014659771        111.27016
## equip      0.0216395305          0.006652447         49.98919
## etat       0.0055383727          0.003876559         26.16402
## contr      0.0016693748          0.003348812         26.27570
## droit      0.0018757171          0.004658075         28.25839
## econom     0.0050730716          0.004580075         30.20398
## general    0.0013204813          0.002814179         17.84984
## national   0.0016731801          0.003864257         27.26904
## social     0.0035875464          0.003366529         27.20141
## final      0.0207030357          0.005979771         53.12316
varImpPlot(modele_rf)



 #copie des termes dans l'attente de trouver une méthode pour récup les variables d'une matrice.
# sachant que les mots ne sont pas constant d'une éxécution du code à l'autre
modele_25 = randomForest(category~ selon + film + loi + entrepris + president + ete + ministr + festival + scen + gouvern + contr + franc + match + person + art + general + social + equip + droit + national + etat + final + econom + plac
                         , data=training,
                         importance = T,
                         proximity=TRUE,
                         ntree = 100)
plot(modele_25)



Prediction

#jeu d'entrainement
predict_25_train <- predict(modele_25, newdata=training, type= "prob")[,1]
#jeu de test
predict_25 <- predict(modele_25, newdata=testing, type= "prob")[,1]



AUC

library(ROCR)
library(pROC)
#length(base_modelisation[-nb_lignes,]$category)

#jeu d'entrainement
auc(training$category, predict_25_train)
## Warning in roc.default(response, predictor, auc = TRUE, ...): 'response'
## has more than two levels. Consider setting 'levels' explicitly or using
## 'multiclass.roc' instead
## Setting levels: control = culture, case = economie
## Setting direction: controls > cases
## Area under the curve: 0.9357
#jeu de test
auc(testing$category, predict_25)
## Warning in roc.default(response, predictor, auc = TRUE, ...): 'response'
## has more than two levels. Consider setting 'levels' explicitly or using
## 'multiclass.roc' instead
## Setting levels: control = culture, case = economie
## Setting direction: controls > cases
## Area under the curve: 0.8885

AUC jeu d’entrainement : 0.93 AUC jeu de test : 0.87

L’AUC augmente de 0.01 pour un passage de 440 variables à 25.



Test Prediction

table(predict_25, testing$category)[1,]
##   culture  economie   planete politique   societe     sport 
##         0         6         3        25        24        21



Fréquence conditionel (prédiction avec jeu d’entrainement)

table(predict(modele_25), training$category)
##            
##             culture economie planete politique societe sport
##   culture      1407      260     155       113     415   183
##   economie      100      682     100       129     268    42
##   planete         1        3      16         4       9     1
##   politique      44      117      49       459     256    19
##   societe       179      347     260       384    1259    73
##   sport          34       40       7         9      36   540



#Visualisation de la prédiction
plot(predict_25 ~ category, data=testing, xlab="Observe",
       ylab="Predis")

Conclusion



Nos 3 modèles sont utilisables. La forte réduction du nombre de variable sur le modèle randomForest a eu un impact mineur sur l’AUC.